module WS.Runtime.XML where

import WS.Runtime.Xmlable
import Text.XML.Light 
import Data.Char
import Codec.Binary.UTF8.String
import Data.List
import Control.Arrow

toXml :: (Xmlable t) => String -> String -> t -> String
-- toXml withAttr root frstName = decodeXml . showTopElement . {- (if withAttr then changeElement else id) . -}
--     unode root . (if null frstName then concat else map (Elem . unode frstName)) . toContent
toXml root frstName = decodeXml . showTopElement . 
    (if null frstName then unode root . head  else unode root . map (Elem . unode frstName)) . toAttrContent

fromXml :: (Xmlable t) => String -> String -> String -> t
-- fromXml root frstName = fromContent . (if null frstName then id else map elContent . onlyElems . concat) . 
--        map elContent . filter ((== unqual root) . elName) . onlyElems . parseXML
fromXml root frstName = fromAttrContent . (if null frstName then id else map (elAttribs &&& elContent) . onlyElems . concat . map snd) . 
        map (elAttribs &&& elContent) . filter ((== unqual root) . elName) . onlyElems . parseXML

decodeXml :: String -> String
decodeXml sxml = reverse $ (\(s, cur, _) -> cur ++ s) $ foldl (\(s, cur, buf) c -> 
        case c of
            '&' | null cur      -> (s, "&", buf)
                | cur == "&"    -> ('&':'&':s, "", [])
                | otherwise     -> ('&':cur ++ s, [], [])
            '#' | cur == "&"    -> (s, "#&", buf)
                | otherwise     -> ('#':cur ++ s, [], [])
            ';' | "#&" `isSuffixOf` cur && to_int cur >= 256 -> (to_chr cur : s, [], [])
                | "#&" `isSuffixOf` cur && to_int cur < 256 && null buf -> (s, [], [to_chr cur])
                | "#&" `isSuffixOf` cur && to_int cur < 256 && not (null buf) -> (decodeString (reverse $ to_chr cur : buf) ++ s, [], [])
                | otherwise     -> (';':cur ++ s, [], [])
            _   | isDigit c && ("#&" `isPrefixOf` cur || any isDigit (take 1 cur)) -> (s, c:cur, buf)
                | otherwise -> (c:cur ++ s, [], [])
    ) ([], [], []) sxml
    where
        to_int = (read :: String -> Int) . reverse . init . init
        to_chr = chr . to_int

{-
canBeAttr :: Content -> Bool
canBeAttr (Elem Element { elContent = [Text cd] }) = not $ any (`elem` "<>") $ cdData cd
canBeAttr _ = False

mkAttr :: Content -> Attr
mkAttr (Elem e@(Element { elContent = [Text cd] })) = Attr { attrKey = elName e, attrVal = cdData cd }
mkAttr c = error $ unlines ["Wrong trying to make attribute from content:", show c]
-}

{-
mkAttrContent :: [Content] -> ([Attr], [Content])
mkAttrContent = (map mkAttr *** map changeContent) . partition canBeAttr

changeContent :: Content -> Content
changeContent (Elem e) = Elem $ changeElement e
changeContent c = c

changeElement :: Element -> Element
changeElement e = e { elContent = snd $ ac e, elAttribs = fst $ ac e }
    where
        ac = mkAttrContent . elContent

-}